home *** CD-ROM | disk | FTP | other *** search
/ Netware Super Library / Netware Super Library.iso / menu_pgm / mcmenu / syssup.pas < prev    next >
Pascal/Delphi Source File  |  1992-08-22  |  10KB  |  373 lines
  1. UNIT SysSup;
  2. { nov 23 91 tb
  3.   has screen blanker for programs that call allowkey
  4.   August 11 92 tb  minor spelling fix for 'tuesday'
  5.   aug 23 92 1.520 set blank time to 5 minutes
  6. }
  7.  
  8. {$D-,S-}
  9.  
  10. INTERFACE
  11.  
  12. USES Crt,Dos,Win;
  13.  
  14. CONST
  15.   bs=08;
  16.   esc=27;
  17.   left=18; {75}
  18.   right=04; {77}
  19.   up=5; {72}
  20.   down=24 {80};
  21.   space = 32;
  22.   return = 13;
  23.   hotkey = 59; {59}
  24.   blanks='                                                                                ';
  25.  
  26. TYPE
  27.   keysettype= SET OF CHAR;
  28.   helpstr= STRING[8];
  29.  
  30. VAR
  31.   helpon,inhelp: BOOLEAN;
  32.   curhelp: helpstr;
  33.   hasmouse: BOOLEAN;
  34.   blankerstr: STRING[80];
  35.  
  36. FUNCTION abs(a: INTEGER): INTEGER;
  37.  
  38. FUNCTION max(a,b: INTEGER): INTEGER;
  39.  
  40. FUNCTION min(a,b: INTEGER): INTEGER;
  41.  
  42. FUNCTION limit(low,high,amt: INTEGER): INTEGER;
  43.  
  44. FUNCTION querykey(VAR key: CHAR): BOOLEAN;
  45.  
  46. FUNCTION allowkey(keysallowed: keysettype; scans: INTEGER): CHAR;
  47.   { -1 in scans means wait until key hit any other amount is number of times
  48.     to check for key.  If key is found it is returned as the function, if no
  49.     key is found then a CHR(0) is returned.   }
  50.  
  51. FUNCTION readchar: CHAR;
  52.  
  53. PROCEDURE getxy(VAR x,y: INTEGER);
  54.  
  55. IMPLEMENTATION
  56.  
  57. VAR
  58.   blankon: BOOLEAN;
  59.   datestr: STRING[80];
  60.  
  61.   PROCEDURE getdatetime;
  62.   VAR
  63.     year,month,day,dayofweek: WORD;
  64.     s: STRING;
  65.     hour,minute,second,sec100: WORD;
  66.     i: INTEGER;
  67.  
  68.   BEGIN { getdatetime }
  69.     GetDate(year,month,day,dayofweek);
  70.     CASE dayofweek OF
  71.       0: datestr:='Sunday';
  72.       1: datestr:='Monday';
  73.       2: datestr:='Tuesday';
  74.       3: datestr:='Wednesday';
  75.       4: datestr:='Thursday';
  76.       5: datestr:='Friday';
  77.       6: datestr:='Saturday';
  78.     END; { CASE }
  79.     CASE month OF
  80.       1: datestr:= CONCAT(datestr,' January');
  81.       2: datestr:= CONCAT(datestr,' February');
  82.       3: datestr:= CONCAT(datestr,' March');
  83.       4: datestr:= CONCAT(datestr,' April');
  84.       5: datestr:= CONCAT(datestr,' May');
  85.       6: datestr:= CONCAT(datestr,' June');
  86.       7: datestr:= CONCAT(datestr,' July');
  87.       8: datestr:= CONCAT(datestr,' August');
  88.       9: datestr:= CONCAT(datestr,' September');
  89.      10: datestr:= CONCAT(datestr,' October');
  90.      11: datestr:= CONCAT(datestr,' November');
  91.      12: datestr:= CONCAT(datestr,' December');
  92.     END; { CASE }
  93.     STR(day:2,s);
  94.     datestr:= CONCAT(datestr,' ',s);
  95.     STR(year:4,s);
  96.     datestr:= CONCAT(datestr,' ',s);
  97.     GetTime(hour,minute,second,sec100);
  98.     STR(hour:2,s);
  99.     FOR i:= 1 TO LENGTH(s) DO
  100.       IF s[i]= ' ' THEN
  101.         s[i]:='0';
  102.     datestr:= CONCAT(datestr,' ',s);
  103.     STR(minute:2,s);
  104.     FOR i:= 1 TO LENGTH(s) DO
  105.       IF s[i]= ' ' THEN
  106.         s[i]:='0';
  107.     datestr:= CONCAT(datestr,':',s);
  108.     STR(second:2,s);
  109.     FOR i:= 1 TO LENGTH(s) DO
  110.       IF s[i]= ' ' THEN
  111.         s[i]:='0';
  112.     datestr:= CONCAT(datestr,':',s);
  113.   END; { getdatetime }
  114.  
  115.   FUNCTION abs(a: INTEGER): INTEGER;
  116.   BEGIN { abs }
  117.     IF a < 0 THEN abs := -a ELSE abs := a;
  118.   END; { abs }
  119.  
  120.   FUNCTION max(a,b: INTEGER): INTEGER;
  121.   BEGIN { max  }
  122.     IF a > b THEN max := a ELSE max := b;
  123.   END; { max }
  124.  
  125.   FUNCTION min(a,b: INTEGER): INTEGER;
  126.   BEGIN { min }
  127.     IF a < b THEN min := a ELSE min := b;
  128.   END; {min }
  129.  
  130.   FUNCTION limit(low,high,amt: INTEGER): INTEGER;
  131.   BEGIN { limit }
  132.     IF amt < low THEN limit := low
  133.     ELSE IF amt > high THEN limit := high
  134.     ELSE limit := amt;
  135.   END; { limit }
  136.  
  137.   function ReadChar: Char;
  138.  
  139.   VAR
  140.     ch: CHAR;
  141.     reg: REGISTERS;
  142.   BEGIN
  143.     ch := readkey;
  144.     IF ch = #0 THEN
  145.     BEGIN
  146.       ch:= readkey;
  147.       if ch=CHR(75) then ch:=CHR(left);
  148.       if ch=CHR(77) then ch:=CHR(right);
  149.       if ch=CHR(72) then ch:=CHR(up);
  150.       if ch=CHR(80) then ch:=CHR(down);
  151.       IF NOT blankon THEN
  152.       BEGIN
  153.         IF ch=CHR(hotkey) THEN
  154.         BEGIN
  155.           IF (helpon AND NOT inhelp) THEN INTR(250,reg);
  156.           ch:=CHR(0);
  157.         END; { hotkey }
  158.       END; { NOT blankon }
  159.     END; { ch= 0 prefixed }
  160.      readchar := ch;
  161.  
  162.   END; { readchar }
  163.  
  164.   FUNCTION querykey(VAR key: CHAR): BOOLEAN;
  165.   VAR
  166.     keyhit: BOOLEAN;
  167.     reg: registers;
  168.   BEGIN { querykey }
  169.     { check mouse }
  170.     keyhit:= FALSE;
  171.     key:=CHR(0);
  172.       delay(50); { give mickeys time to build up }
  173.                  { and time for keys to buffer }
  174.     IF hasmouse THEN
  175.     BEGIN
  176.       reg.AX:=05;
  177.       reg.BX:=0; { left button }
  178.       INTR($33,reg); { get button status }
  179.       keyhit:=reg.bx<>0;
  180.       IF keyhit THEN
  181.         key:=CHR(return);
  182.       IF NOT keyhit THEN
  183.       BEGIN
  184.         reg.AX:=05;
  185.         reg.BX:=1; { right button }
  186.         INTR($33,reg); { get button status }
  187.         keyhit:=reg.bx<>0;
  188.         IF keyhit THEN
  189.           key:=CHR(esc);
  190.       END;
  191.       IF NOT keyhit THEN
  192.       BEGIN
  193.         reg.AX:=$0B;   { get mouse motion mickeys }
  194.         INTR($33,reg);
  195.         { check mouse motion 25 mickeys to be effective }
  196.         { neg val = up pos down }
  197.         keyhit:= ((reg.DX>25) AND (reg.DX<300))
  198.            OR ((reg.DX>65000) AND (reg.DX<65510));
  199.         IF keyhit THEN
  200.           IF reg.DX >300 THEN
  201.             key:= CHR(up)
  202.           ELSE
  203.             key:= CHR(down);
  204.       { 0.720}
  205.         IF keyhit THEN
  206.         BEGIN
  207.           delay(150); { debounce mouse movement to 6 keys/second }
  208.           reg.AX:=$0B;   { empty mouse mickey count }
  209.          INTR($33,reg);
  210.         END;  { was valid mouse movement }
  211.       END;
  212.     END; { hasmouse }
  213.     keyhit:= keypressed OR keyhit;
  214.     IF keypressed  THEN
  215.       key:= readchar;
  216.     querykey:= keyhit;
  217.  
  218.   END; { querykey }
  219.  
  220.  
  221.   FUNCTION allowkey(keysallowed: keysettype; scans: INTEGER): CHAR;
  222.   { -1 in scans means wait until key hit any other amount is number of times
  223.     to check for key.  If key is found it is returned as the function, if no
  224.     key is found then a CHR(0) is returned.   }
  225.  
  226.   TYPE
  227.     winrec = RECORD
  228.       state: winstate;
  229.       buffer: POINTER;
  230.     END;
  231.     winrecptr = ^winrec;
  232.  
  233.   CONST
  234.     timetoblank=300;                      { 1.520 }
  235.     timetomove=5;                         { 0.724 }
  236.     blankattr= lightgray+black*16;
  237.     mmsgattr= black+lightgray*16;
  238.     cmsgattr= lightgray+blue*16;
  239.  
  240.   VAR
  241.     keyhit: BOOLEAN;
  242.     key: CHAR;
  243.     time: INTEGER;
  244.     ir: INTEGER;
  245.     ohour,omin,osec,osec100: WORD;
  246.     nhour,nmin,nsec,nsec100: WORD;
  247.     timelastmove: INTEGER;
  248.     blankwin: winrecptr;
  249.     msgwin: winrecptr;
  250.     oldwin: winstate;
  251.     x,y: INTEGER;
  252.     attr: INTEGER;
  253.     tscans: INTEGER;
  254.  
  255.     PROCEDURE openwindow(x1, y1, x2, y2: BYTE;VAR w: winrecptr);
  256.     BEGIN
  257.       NEW(w);
  258.       WITH w^ DO
  259.       BEGIN
  260.         savewin(state);
  261.         window(x1, y1, x2, y2);
  262.         GETMEM(buffer, winsize);
  263.         readwin(buffer^);
  264.       END;
  265.     END;
  266.  
  267.     PROCEDURE closewindow(VAR w: winrecptr);
  268.     BEGIN
  269.       WITH w^ DO
  270.       BEGIN
  271.         writewin(buffer^);
  272.         FREEMEM(buffer, winsize);
  273.         restorewin(state);
  274.       END;
  275.       DISPOSE(w);
  276.     END;
  277.  
  278.   BEGIN { allowkey }
  279.     tscans:=scans;
  280.     IF lastmode=mono THEN
  281.       attr:=mmsgattr
  282.     ELSE
  283.       attr:=cmsgattr;
  284.     keyhit:= FALSE;
  285.     blankon:= FALSE;
  286.     gettime(ohour,omin,osec,osec100);
  287.     WHILE (tscans <> 0) AND NOT(keyhit) DO
  288.     BEGIN { WHILE }
  289.       gettime(nhour,nmin,nsec,nsec100);
  290.       IF nmin<omin THEN
  291.         nmin:=nmin+60;
  292.       IF blankon THEN
  293.       BEGIN
  294.         IF timetomove<= ((nmin*60)+nsec)-((omin*60)+osec)THEN
  295.         BEGIN
  296.           REPEAT
  297.             gettime(ohour,omin,osec,osec100);
  298.           UNTIL (osec MOD timetomove)=0; { 0.725 put onto regular boundry }
  299.           unframewin;
  300.           closewindow(msgwin);
  301.           x:=random(24)+1;
  302.           y:=random(15)+1;
  303.           openwindow(x,y,x+45,y+6,msgwin);
  304.           tframewin(blankerstr,
  305.             doubleframe,attr,attr);
  306.           fillwin(#32,attr);
  307.           textattr:=attr;
  308.           getdatetime;
  309.           WriteStr((48-LENGTH(datestr)) DIV 2,2,datestr,attr);
  310.           WriteStr(16,4,'Press any key',attr);
  311.         END; { time to move }
  312.  
  313.       END; { blankon }
  314.       IF NOT blankon THEN
  315.       BEGIN
  316.         IF timetoblank< ((nmin*60)+nsec)-((omin*60)+osec)THEN
  317.         BEGIN
  318.           blankon:= TRUE;
  319.           REPEAT
  320.             gettime(ohour,omin,osec,osec100);
  321.           UNTIL (osec MOD timetomove)=0; { 0.725 put onto regular boundry }
  322.           openwindow(1,1,80,25,blankwin);
  323.           fillwin(#32,blankattr);
  324.           openwindow(15,8,60,14,msgwin);
  325.           tframewin(blankerstr,
  326.             doubleframe,attr,attr);
  327.           fillwin(#32,attr);
  328.           textattr:=attr;
  329.           getdatetime;
  330.           WriteStr((48-LENGTH(datestr)) DIV 2,2,datestr,attr);
  331.           WriteSTr(16,4,'Press any key',attr);
  332.         END; { start up blanker }
  333.       END; { not blankon }
  334.       IF (tscans <> -1) THEN tscans:= tscans-1;
  335.       keyhit := querykey(key);
  336.  
  337.       IF keyhit THEN
  338.       BEGIN
  339.        keyhit:=  ((key IN keysallowed) OR (keysallowed = []));
  340.         gettime(ohour,omin,osec,osec100);
  341.         IF blankon THEN
  342.         BEGIN
  343.           keyhit:= FALSE;
  344.           blankon:= FALSE;
  345.           unframewin;
  346.           closewindow(msgwin);
  347.           closewindow(blankwin);
  348.         END; { turn off blanker }
  349.       END; { keyhit }
  350.     END; { WHILE }
  351.     IF keyhit
  352.     THEN allowkey := key
  353.     ELSE allowkey := CHR(0);
  354.   END; { allowkey }
  355.  
  356.   FUNCTION anykey: CHAR;
  357.   BEGIN { anykey }
  358.    anykey := allowkey([],-1);
  359.   END; { anykey }
  360.  
  361.   PROCEDURE getxy(VAR x,y: INTEGER);
  362.   BEGIN { getxy }
  363.     X:= wherex;
  364.     y:= wherey;
  365.   END; { getxy }
  366.  
  367. BEGIN { SysSup }
  368.   hasmouse:= FALSE;
  369.   helpon:= FALSE;
  370.   inhelp:= FALSE;
  371.   blankon:= FALSE;
  372.   blankerstr:= 'Blanker';
  373. END. { SysSup }